home *** CD-ROM | disk | FTP | other *** search
/ PD Collection CD 1 / PD Collection CD 1.iso / programer2 / lisp / xlisp / !XLisp / c / XLIO < prev    next >
Text File  |  1990-02-23  |  3KB  |  162 lines
  1. /* xlio - xlisp i/o routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "io"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE ***xlstack;
  14. extern NODE *s_stdin,*s_unbound;
  15. extern int xlfsize;
  16. extern int xlplevel;
  17. extern int xldebug;
  18. extern int prompt;
  19. extern char buf[];
  20.  
  21. /* xlgetc - get a character from a file or stream */
  22. int xlgetc(fptr)
  23.   NODE *fptr;
  24. {
  25.     NODE *lptr,*cptr;
  26.     FILE *fp;
  27.     int ch;
  28.  
  29.     /* check for input from nil */
  30.     if (fptr == NIL)
  31.     ch = EOF;
  32.  
  33.     /* otherwise, check for input from a stream */
  34.     else if (consp(fptr)) {
  35.     if ((lptr = car(fptr)) == NIL)
  36.         ch = EOF;
  37.     else {
  38.         if (!consp(lptr) ||
  39.         (cptr = car(lptr)) == NIL || !fixp(cptr))
  40.         xlfail("bad stream");
  41.         if (rplaca(fptr,cdr(lptr)) == NIL)
  42.         rplacd(fptr,NIL);
  43.         ch = getfixnum(cptr);
  44.     }
  45.     }
  46.  
  47.     /* otherwise, check for a buffered file character */
  48.     else if (ch = getsavech(fptr))
  49.     setsavech(fptr,0);
  50.  
  51.     /* otherwise, get a new character */
  52.     else {
  53.  
  54.     /* get the file pointer */
  55.     fp = getfile(fptr);
  56.  
  57.     /* prompt if necessary */
  58.     if (prompt && fp == stdin) {
  59.  
  60.         /* print the debug level */
  61.         if (xldebug)
  62.         { sprintf(buf,"%d:",xldebug); stdputstr(buf); }
  63.  
  64.         /* print the nesting level */
  65.         if (xlplevel > 0)
  66.         { sprintf(buf,"%d",xlplevel); stdputstr(buf); }
  67.  
  68.         /* print the prompt */
  69.         stdputstr("> ");
  70.         prompt = FALSE;
  71.     }
  72.  
  73.     /* get the character */
  74.     if (((ch = osgetc(fp)) == '\n' || ch == EOF) && fp == stdin)
  75.         prompt = TRUE;
  76.     }
  77.  
  78.     /* return the character */
  79.     return (ch);
  80. }
  81.  
  82. /* docommand - create a nested MS-DOS shell */
  83. #ifdef SYSTEM
  84. docommand()
  85. {
  86.     stdputstr("\n[ creating a nested command processor ]\n");
  87.     system("COMMAND");
  88.     stdputstr("[ returning to XLISP ]\n");
  89. }
  90. #endif
  91.  
  92. /* xlpeek - peek at a character from a file or stream */
  93. int xlpeek(fptr)
  94.   NODE *fptr;
  95. {
  96.     NODE *lptr,*cptr;
  97.     int ch;
  98.  
  99.     /* check for input from nil */
  100.     if (fptr == NIL)
  101.     ch = EOF;
  102.  
  103.     /* otherwise, check for input from a stream */
  104.     else if (consp(fptr)) {
  105.     if ((lptr = car(fptr)) == NIL)
  106.         ch = EOF;
  107.     else {
  108.         if (!consp(lptr) ||
  109.         (cptr = car(lptr)) == NIL || !fixp(cptr))
  110.         xlfail("bad stream");
  111.         ch = getfixnum(cptr);
  112.     }
  113.     }
  114.  
  115.     /* otherwise, get the next file character and save it */
  116.     else
  117.     setsavech(fptr,ch = xlgetc(fptr));
  118.  
  119.     /* return the character */
  120.     return (ch);
  121. }
  122.  
  123. /* xlputc - put a character to a file or stream */
  124. xlputc(fptr,ch)
  125.   NODE *fptr; int ch;
  126. {
  127.     NODE ***oldstk,*lptr;
  128.  
  129.     /* count the character */
  130.     xlfsize++;
  131.  
  132.     /* check for output to nil */
  133.     if (fptr == NIL)
  134.     ;
  135.  
  136.     /* otherwise, check for output to a stream */
  137.     else if (consp(fptr)) {
  138.     oldstk = xlsave(&lptr,(NODE **)NULL);
  139.     lptr = consa(NIL);
  140.     rplaca(lptr,cvfixnum((FIXNUM)ch));
  141.     if (cdr(fptr))
  142.         rplacd(cdr(fptr),lptr);
  143.     else
  144.         rplaca(fptr,lptr);
  145.     rplacd(fptr,lptr);
  146.     xlstack = oldstk;
  147.     }
  148.  
  149.     /* otherwise, output the character to a file */
  150.     else
  151.     osputc(ch,getfile(fptr));
  152. }
  153.  
  154. /* xlflush - flush the input buffer */
  155. int xlflush()
  156. {
  157.     if (!prompt)
  158.     while (xlgetc(getvalue(s_stdin)) != '\n')
  159.         ;
  160. }
  161.  
  162.